home *** CD-ROM | disk | FTP | other *** search
/ Almathera Ten Pack 3: CDPD 3 / Almathera Ten on Ten - Disc 3: CDPD3.iso / scope / scopedisk24 / AmyCal / Cal.MOD < prev    next >
Text File  |  1988-08-31  |  5KB  |  217 lines
  1. MODULE Cal;
  2.  
  3. (*    A calendar making program written in Benchmark Modula-2.
  4.  
  5.     Cal is a 100% public domain, do-what-you-will program for 
  6.     all Amiga computers. Written by David Czaya (PLINK -Dave- )
  7.     in July 1988.
  8.  
  9.     If you feel obliged, leave my name in any modications. If not, 
  10.     don't lose any sleep. Thanks.
  11.  
  12.  
  13.     The day of the week that the first of the month falls on 
  14.     is determined by Zeller's Congruence. This works for any 
  15.     date since 1582. 
  16.  
  17.         wkday = (d + m*2 + INT((m+1)*.6) + 1 + yr +
  18.                  INT(yr/4) - INT(yr/100) + INT(yr/400)) MOD 7
  19.  
  20.     wkday = weekday          (0=Sun, 1=Mon, 2=Tue, etc.)
  21.         d     = day of the month
  22.         m     = adjusted month   (Jan & Feb = 13 & 14 of previous year)
  23.         yr    = adjusted year    ((yr = yr-1) if month is Jan. or Feb.)
  24. *)
  25.  
  26.  
  27. FROM SYSTEM     IMPORT    ADR, SHORT;
  28. FROM System     IMPORT    argc, argv;
  29. FROM TermInOut     IMPORT    WriteString, WriteCard, WriteLn, Write;
  30. FROM Conversions IMPORT    ConvStringToNumber;
  31. FROM CStrings     IMPORT    strncmp;
  32. FROM AmigaDOS    IMPORT DateStamp, DateStampRecord;
  33.  
  34. CONST
  35.     COLORVID = '\033[33m';
  36.     NORMVID = '\033[m';
  37.     CURSOROFF = '\033[0 p\n';
  38.     CURSORON = '\033[ p\n';
  39.  
  40.     USAGE =                    
  41.  
  42. '\tUsage:  Cal [month] [year]\n\
  43. \t   ex:  Cal January 1988\n\n\
  44. \t100% public domain by David Czaya  July 1988\n';
  45.  
  46. VAR
  47.     yr, monthptr,            (* monthptr is month array pointer *)
  48.     day, wkday, 
  49.     monthlen   : CARDINAL;
  50.     month      : ARRAY [1..12],[0..9] OF CHAR;
  51.     leap       : BOOLEAN;
  52.     yy         : LONGCARD;
  53.     dsrecord   : DateStampRecord;
  54.  
  55.     
  56. PROCEDURE Err1();
  57. BEGIN
  58.     WriteString(USAGE);
  59.     HALT
  60. END Err1;
  61.  
  62.  
  63. PROCEDURE Err2();            (* \7 flashes the screen *)
  64. BEGIN
  65.     WriteString('\7 *** The year must be between 1592 and 9999\n');
  66.     HALT
  67. END Err2;
  68.  
  69.     
  70. PROCEDURE ConvArg1();            (* check for valid "month" input *)    
  71. BEGIN
  72.     FOR monthptr := 0 TO 2 DO
  73.         argv^[1]^[monthptr] := CAP(argv^[1]^[monthptr]);
  74.     END;
  75.     
  76.     FOR monthptr := 1 TO 12 DO
  77.         IF strncmp(ADR(argv^[1]^),ADR(month[monthptr]),3) = 0 THEN
  78.             RETURN
  79.         END;
  80.     END;
  81.     
  82.     Err1();
  83. END ConvArg1;
  84.         
  85.  
  86. PROCEDURE ConvArg2();            
  87. BEGIN                    (* check for valid "year" input, *)
  88.     leap := FALSE;            (* check for leap year and see     *)
  89.     monthlen := 31;            (* how many days are in the      *)
  90.     yr := SHORT(yy);        (* month             *)
  91.  
  92.  
  93.     IF (yr < 100) THEN INC(yr,1900) END;    
  94.     IF (yr < 1592) OR (yr > 9999) THEN Err2() END;
  95.         
  96.     IF (yr MOD 4) = 0 THEN leap := TRUE END;
  97.     IF (yr MOD 100) = 0 THEN leap := FALSE END;
  98.     IF (yr MOD 400) = 0 THEN leap := TRUE END;
  99.  
  100.     IF monthptr = 2 THEN monthlen := 28 END;
  101.     IF leap AND (monthptr = 2) THEN INC(monthlen) END;
  102.     IF (monthptr = 4) OR (monthptr = 6) OR 
  103.      (monthptr = 9) OR (monthptr = 11) THEN DEC(monthlen) END;   
  104. END ConvArg2;
  105.  
  106.  
  107. PROCEDURE GetSysDate(date: DateStampRecord);
  108. VAR
  109.     n,y,m,d : CARDINAL;    
  110. BEGIN
  111.     n := date.dsDays - 2251D;
  112.         y :=  (4 * n + 3) DIV 1461;
  113.         n := n -  ((1461 * y) DIV 4);
  114.         y := y + 1984;
  115.         m :=  ((5 * n + 2) DIV 153);
  116.         d :=  n - (153 * m + 2) DIV 5 + 1;
  117.         INC(m,3);
  118.         IF m > 12 THEN
  119.             INC(y);
  120.               DEC(m,12);  
  121.        END;
  122.  
  123.     monthptr := m;
  124.         day := d;
  125.     yy := y;
  126. END GetSysDate;
  127.  
  128.  
  129. PROCEDURE GetDay();            (* find out what day of the week *)
  130. VAR                    (* the month starts on, using     *)
  131.     m,d,y : CARDINAL;        (* Zeller's Congruence         *)
  132. BEGIN
  133.     m := monthptr;
  134.     d := 1;
  135.     y := yr;
  136.  
  137.     IF m < 3 THEN
  138.         INC(m,12);
  139.         DEC(y);
  140.     END;
  141.  
  142.     wkday := (d + m * 2 + CARDINAL(TRUNC((FLOAT(m) + 1.0) * 0.6)) + 1 + y + 
  143.         (y DIV 4) - (y DIV 100) + (y DIV 400) ) MOD 7;    
  144. END GetDay;
  145.  
  146.  
  147. PROCEDURE PrintCal();            (* format and print calendar     *)
  148. VAR
  149.     len, ctr : CARDINAL;
  150. BEGIN
  151.     len := 0;
  152.  
  153.     WHILE month[monthptr][len] # '\0' DO INC(len) END;
  154.  
  155.     WriteString(CURSOROFF);
  156.  
  157.     FOR ctr := 1 TO ((21-(len+4)) DIV 2) DO Write(40C) END;
  158.     
  159.     WriteString(month[monthptr]);
  160.     WriteCard(yr,5);    
  161.     WriteString('\n\n Su Mo Tu We Th Fr Sa\n\n');
  162.     
  163.     FOR ctr := 1 TO wkday DO
  164.         WriteString('   ');
  165.     END;
  166.     
  167.     FOR ctr := wkday TO monthlen+wkday-1 DO
  168.         IF (ctr = 7) OR (ctr = 14) OR (ctr = 21) OR 
  169.             (ctr = 28) OR (ctr = 35) THEN
  170.             WriteLn;
  171.         END;
  172.  
  173.         IF (ctr-wkday+1) # day THEN
  174.             WriteCard(ctr-wkday+1,3)
  175.         ELSE
  176.             WriteString(COLORVID);
  177.             WriteCard(ctr-wkday+1,3);
  178.             WriteString(NORMVID);
  179.         END;    
  180.     END;
  181.     WriteString(CURSORON);
  182. END PrintCal;
  183.  
  184.  
  185. BEGIN
  186.     month[01]:= 'JANUARY';
  187.       month[02]:= 'FEBRUARY';
  188.       month[03]:= 'MARCH';
  189.       month[04]:= 'APRIL';
  190.       month[05]:= 'MAY';
  191.       month[06]:= 'JUNE';
  192.       month[07]:= 'JULY';
  193.       month[08]:= 'AUGUST';
  194.       month[09]:= 'SEPTEMBER';
  195.       month[10]:= 'OCTOBER';
  196.       month[11]:= 'NOVEMBER';
  197.       month[12]:= 'DECEMBER';
  198.  
  199.  
  200. (* Start here *)
  201.  
  202.     CASE argc OF
  203.     
  204.     1 :    DateStamp(dsrecord);
  205.         GetSysDate(dsrecord)    |
  206.     2 :    Err1()            |
  207.     3 :    IF NOT ConvStringToNumber(argv^[2]^,yy,FALSE,10) THEN Err1() 
  208.         ELSE ConvArg1()    END
  209.     ELSE
  210.         Err1();
  211.     END;            
  212.  
  213.     ConvArg2();        
  214.     GetDay();
  215.     PrintCal();
  216. END Cal.
  217.